home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / LANG / SCHEME / GNU / SCM4E1 / !Scm / slib / scmacro < prev    next >
Text File  |  1994-02-14  |  3KB  |  110 lines
  1. ;;; -*- Scheme -*-
  2. ;;;; scmacro.scm: Chris Hanson's Syntactic Closures macro implementation.
  3.  
  4. ;;;; Syntaxer Output Interface
  5.  
  6. (define syntax-error slib:error)
  7.  
  8. (define impl-error slib:error)
  9.  
  10. (define (append-map procedure . lists)
  11.   (apply append (apply map (cons procedure lists))))
  12.  
  13. (define *counter* 0)
  14.  
  15. (define (make-name-generator)
  16.   (let ((suffix-promise
  17.      (make-promise
  18.       (lambda ()
  19.         (string-append "."
  20.                (number->string (begin
  21.                          (set! *counter* (+ *counter* 1))
  22.                          *counter*)))))))
  23.     (lambda (identifier)
  24.       (string->symbol
  25.        (string-append "."
  26.               (symbol->string (identifier->symbol identifier))
  27.               (promise:force suffix-promise))))))
  28.  
  29. (define (output/variable name)
  30.   name)
  31.  
  32. (define (output/literal-unquoted datum)
  33.   datum)
  34.  
  35. (define (output/literal-quoted datum);was output/constant (inefficient)
  36.   `(QUOTE ,datum))
  37.  
  38. (define (output/assignment name value)
  39.   `(SET! ,name ,value))
  40.  
  41. (define (output/top-level-definition name value)
  42.   `(DEFINE ,name ,value))
  43.  
  44. (define (output/conditional predicate consequent alternative)
  45.   `(IF ,predicate ,consequent ,alternative))
  46.  
  47. (define (output/sequence expressions)
  48.   (if (null? (cdr expressions))
  49.       (car expressions)
  50.       `(BEGIN ,@expressions)))
  51.  
  52. (define (output/combination operator operands)
  53.   `(,operator ,@operands))
  54.  
  55. (define (output/lambda pattern body)
  56.   `(LAMBDA ,pattern ,body))
  57.  
  58. (define (output/delay expression)
  59.   `(DELAY ,expression))
  60.  
  61. (define (output/unassigned)
  62.   `'*UNASSIGNED*)
  63.  
  64. (define (output/unspecific)
  65.   `'*UNSPECIFIC*)
  66.  
  67. (require 'promise)            ; Portable support for force and delay.
  68. (require 'record)
  69. (require 'synchk)            ; Syntax checker.
  70.  
  71. ;;; This file is the macro expander proper.
  72. (slib:load (in-vicinity (library-vicinity) "synclo"))
  73.  
  74. ;;; These files define the R4RS syntactic environment.
  75. (slib:load (in-vicinity (library-vicinity) "r4rsyn"))
  76. (slib:load (in-vicinity (library-vicinity) "synrul"))
  77.  
  78. ;;; OK, time to build the databases.
  79. (initialize-scheme-syntactic-environment!)
  80.  
  81. ;;; MACRO:EXPAND is for you to use.  It takes an R4RS expression, macro-expands
  82. ;;; it, and returns the result of the macro expansion.
  83. (define (synclo:expand expression)
  84.   (set! *counter* 0)
  85.   (compile/top-level (list expression) scheme-syntactic-environment))
  86. (define macro:expand synclo:expand)
  87.  
  88. ;;; Here are EVAL, EVAL! and LOAD which expand macros.  You can replace the
  89. ;;; implementation's eval and load with them if you like.
  90. (define base:eval slib:eval)
  91. (define base:load load)
  92.  
  93. (define (synclo:eval x) (base:eval (macro:expand x)))
  94. (define macro:eval synclo:eval)
  95.  
  96. (define (synclo:load <pathname>)
  97.   (call-with-input-file <pathname>
  98.     (lambda (port)
  99.       (let ((old-load-pathname *load-pathname*))
  100.     (set! *load-pathname* <pathname>)
  101.     (do ((o (read port) (read port)))
  102.         ((eof-object? o))
  103.       (macro:eval o))
  104.     (set! *load-pathname* old-load-pathname)))))
  105. (define macro:load synclo:load)
  106.  
  107. (provide 'syntactic-closures)
  108. (provide 'macro)            ;Here because we may have
  109.                     ;(require 'sc-macro)
  110.